home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / s-taprob.adb < prev    next >
Text File  |  1994-05-19  |  21KB  |  657 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --      S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S     --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.9 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
  12. --                                                                          --
  13. --  GNARL is free software; you can redistribute it and/or modify it  under --
  14. --  terms  of  the  GNU  Library General Public License as published by the --
  15. --  Free Software Foundation; either version 2,  or (at  your  option)  any --
  16. --  later  version.   GNARL is distributed in the hope that it will be use- --
  17. --  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
  18. --  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. --  eral Library Public License for more details.  You should have received --
  20. --  a  copy of the GNU Library General Public License along with GNARL; see --
  21. --  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
  22. --  Ave, Cambridge, MA 02139, USA.                                          --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Compiler_Exceptions;
  27. --  Used for, Compiler_Exceptions."="
  28. --            Compiler_Exceptions.Raise_Exceptions
  29.  
  30. with System.Error_Reporting;
  31. --  Used for, System.Error_Reporting.Assert
  32.  
  33. with System.Tasking.Abortion;
  34. --  Used for, Abortion.Defer_Abortion,
  35. --            Abortion.Undefer_Abortion
  36. --            Abortion.Abort_To_Level
  37.  
  38. with System.Task_Primitives; use System.Task_Primitives;
  39.  
  40. with System.Tasking.Runtime_Types;
  41. --  Used for, Runtime_Types.ATCB_Ptr,
  42. --            Runtime_Types.ATCB_To_ID,
  43. --            Runtime_Types.ID_To_ATCB
  44.  
  45. package body System.Tasking.Protected_Objects is
  46.  
  47.    procedure Assert (B : Boolean; M : String)
  48.      renames Error_Reporting.Assert;
  49.  
  50.    function ID_To_ATCB (ID : Task_ID) return Runtime_Types.ATCB_Ptr
  51.      renames Tasking.Runtime_Types.ID_To_ATCB;
  52.  
  53.    function ATCB_To_ID (Ptr : Runtime_Types.ATCB_Ptr) return Task_ID
  54.      renames Runtime_Types.ATCB_To_ID;
  55.  
  56.    procedure Defer_Abortion
  57.      renames Abortion.Defer_Abortion;
  58.  
  59.    procedure Undefer_Abortion
  60.      renames Abortion.Undefer_Abortion;
  61.  
  62. --   function "=" (L, R : System.Address) return Boolean renames System."=";
  63. --   why is this commented out ???
  64.  
  65.    function "=" (L, R : Runtime_Types.ATCB_Ptr) return Boolean
  66.      renames Runtime_Types."=";
  67.  
  68. --  This is temporarily commented out. Gnat produces internal error ???
  69. --  function "=" (L, R : Task_ID) return Boolean
  70. --         renames "=";
  71.  
  72.    function "=" (L, R : Exception_ID) return Boolean
  73.      renames Compiler_Exceptions."=";
  74.  
  75.    -----------------------------
  76.    -- Raise_Pending_Exception --
  77.    -----------------------------
  78.  
  79.    procedure Raise_Pending_Exception (Block : Communication_Block) is
  80.       T  : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Block.Self);
  81.       Ex : Exception_ID := T.Exception_To_Raise;
  82.    begin
  83.  
  84.       T.Exception_To_Raise := Null_Exception;
  85.       Compiler_Exceptions.Raise_Exception (Ex);
  86.    end Raise_Pending_Exception;
  87.  
  88.    ---------------------
  89.    -- Check_Exception --
  90.    ---------------------
  91.  
  92.    procedure Check_Exception is
  93.       T  : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Self);
  94.       Ex : Exception_ID := T.Exception_To_Raise;
  95.  
  96.    begin
  97.       T.Exception_To_Raise := Null_Exception;
  98.       Compiler_Exceptions.Raise_Exception (Ex);
  99.    end Check_Exception;
  100.  
  101.    ---------------------------
  102.    -- Initialize_Protection --
  103.    ---------------------------
  104.  
  105.    procedure Initialize_Protection
  106.      (Object           : Protection_Access;
  107.       Ceiling_Priority : Integer)
  108.    is
  109.       Init_Priority : Integer := Ceiling_Priority;
  110.  
  111.    begin
  112.       if Init_Priority = Unspecified_Priority then
  113.          Init_Priority := System.Default_Priority;
  114.       end if;
  115.  
  116.       Initialize_Lock (Init_Priority, Object.L);
  117.       Object.Pending_Call := null;
  118.       Object.Call_In_Progress := null;
  119.  
  120.       for E in Object.Entry_Queues'range loop
  121.          Object.Entry_Queues (E).Head := null;
  122.          Object.Entry_Queues (E).Tail := null;
  123.       end loop;
  124.    end Initialize_Protection;
  125.  
  126.    -------------------------
  127.    -- Finalize_Protection --
  128.    -------------------------
  129.  
  130.    procedure Finalize_Protection (Object : Protection_Access) is
  131.    begin
  132.       --  Need to purge entry queues and pending entry call here. ???
  133.  
  134.       Finalize_Lock (Object.L);
  135.    end Finalize_Protection;
  136.  
  137.    ----------
  138.    -- Lock --
  139.    ----------
  140.  
  141.    procedure Lock (Object : Protection_Access) is
  142.    begin
  143.       Write_Lock (Object.L);
  144.    end Lock;
  145.  
  146.    --------------------
  147.    -- Lock_Read_Only --
  148.    --------------------
  149.  
  150.    procedure Lock_Read_Only (Object : Protection_Access) is
  151.    begin
  152.       Read_Lock (Object.L);
  153.    end Lock_Read_Only;
  154.  
  155.    ------------
  156.    -- Unlock --
  157.    ------------
  158.  
  159.    procedure Unlock (Object : Protection_Access) is
  160.    begin
  161.       Unlock (Object.L);
  162.    end Unlock;
  163.  
  164.    --------------------------
  165.    -- Protected_Entry_Call --
  166.    --------------------------
  167.  
  168.    procedure Protected_Entry_Call
  169.      (Object    : Protection_Access;
  170.       E         : Protected_Entry_Index;
  171.       Uninterpreted_Data : System.Address;
  172.       Mode      : Call_Modes;
  173.       Block     : out Communication_Block)
  174.    is
  175.       Level : ATC_Level;
  176.       Caller : Runtime_Types.ATCB_Ptr := ID_To_ATCB (Self);
  177.  
  178.    begin
  179.       Block.Self := ATCB_To_ID (Caller);
  180.       Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;
  181.       Level := Caller.ATC_Nesting_Level;
  182.  
  183.       Object.Pending_Call := Caller.Entry_Calls (Level)'access;
  184.  
  185.       --   I don't think that we need the calling task's lock here.
  186.       --   Only the calling task will get to access this record until
  187.       --   it is queued, since the calling task
  188.       --   will call Next_Entry_Call before releasing the PO lock,
  189.       --   and since Next_Entry_Call always removes Pending_Call. ???
  190.  
  191.       Object.Pending_Call.Next := null;
  192.       Object.Pending_Call.Call_Claimed := False;
  193.       Object.Pending_Call.Mode := Mode;
  194.       Object.Pending_Call.Abortable := True;
  195.       Object.Pending_Call.Done := False;
  196.       Object.Pending_Call.E := Entry_Index (E);
  197.       Object.Pending_Call.Prio := Caller.Current_Priority;
  198.       Object.Pending_Call.Uninterpreted_Data := Uninterpreted_Data;
  199.       Object.Pending_Call.Called_PO := Protection_Access (Object);
  200.  
  201.       Object.Pending_Call.Called_Task := Null_Task;
  202.       Object.Pending_Call.Exception_To_Raise := Null_Exception;
  203.  
  204.    end Protected_Entry_Call;
  205.  
  206.    --------------------------------------------
  207.    -- Vulnerable_Cancel_Protected_Entry_Call --
  208.    --------------------------------------------
  209.  
  210.    procedure Vulnerable_Cancel_Protected_Entry_Call
  211.      (Caller         : Runtime_Types.ATCB_Ptr;
  212.       Call           : Entry_Call_Link;
  213.       PO             : Protection_Access;
  214.       Call_Cancelled : out Boolean)
  215.    is
  216.       TAS_Result : Boolean;
  217.  
  218.    begin
  219.       Test_And_Set (Call.Call_Claimed'Address, TAS_Result);
  220.  
  221.       if TAS_Result then
  222.          Lock (PO);
  223.          Dequeue (PO.Entry_Queues (Protected_Entry_Index (Call.E)), Call);
  224.  
  225.       else
  226.          Write_Lock (Caller.L);
  227.  
  228.          while not Call.Done loop
  229.             Cond_Wait (Caller.Rend_Cond, Caller.L);
  230.          end loop;
  231.  
  232.          Unlock (Caller.L);
  233.       end if;
  234.  
  235.       Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level - 1;
  236.  
  237.       Write_Lock (Caller.L);
  238.  
  239.       if Caller.Pending_ATC_Level = Caller.ATC_Nesting_Level then
  240.          Caller.Pending_ATC_Level := ATC_Level